home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / process.d < prev    next >
Lisp/Scheme  |  1986-05-30  |  13KB  |  613 lines
  1. /*
  2. (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. */
  4.  
  5. /*
  6.     process.d
  7.     DG-SPECIFIC
  8. */
  9.  
  10. /*
  11.  
  12. create a son process
  13.  
  14. (process "progname.pr"
  15.     &optional "ipc-message"
  16.     &key :block :console :debug :dir :username :list :data :ioc :prtype)
  17.  
  18. progname.pr    Speicfy program name. ".pr" is not added automatically.
  19. ipc-message    Specify ipc message passed to progname.pr. You must
  20.         follow the IPC message rule. For example, you must
  21.         split each argument by "," characater.
  22.         The default is an empty string.
  23.  
  24. :block t        block the lisp until new process terminates
  25.                 The default is T.
  26. :console ":PER:CON??"    set process console to :PER:CON??
  27. :debug t        begin execution in the debugger
  28. :dir "PATHNAME"        set intitial working directory to PATHNAME
  29. :username "USER"    set user name to USER
  30. :list "LISTFILE"    set :PER:LIST to LISTFILE
  31. :list t            set :PER:LIST to :PER:LIST of lisp
  32. :data "DATAFILE"    set :PER:DATA to DATAFILE
  33. :data t            set :PER:DATA to :PER:DATA of lisp
  34. :ioc t            set :PER:INPUT, :PER:OUTPUT and :PER:CONSOLE
  35.                 same as lisp
  36.                 The default is T.
  37. :prtype TYPE        set the process type to TYPE
  38.             TYPE should be one of
  39.                 :swappable (default)
  40.                 :pre-emptive
  41.                 :resident
  42. */
  43.  
  44. #include <sysid.h>
  45. #include <paru.h>
  46. #include <packets:ipc.h>
  47. #include <packets:process.h>
  48. #include <packets:create.h>                    /**/
  49. #include "include.h"
  50.  
  51. static object Kblock;
  52. static object Kconsole;
  53. static object Kdebug;
  54. static object Kdir;
  55. static object Kusername;
  56. static object Klist;
  57. static object Kdata;
  58. static object Kioc;
  59.  
  60. static object Kprtype;
  61. static object Kswappable;
  62. static object Kpre_emptive;
  63. static object Kresident;
  64.  
  65. static
  66. string_copy(x, buff)
  67. object x;
  68. char *buff;
  69. {
  70.     int i, j;
  71.     char *c;
  72.  
  73.     j = x->st.st_fillp;
  74.     c = x->st.st_self;
  75.  
  76.     for (i = 0; i < j; i++)
  77.         buff[i] = c[i];
  78.     buff[i] = '\0';
  79. }
  80.  
  81. @(defun process (progname
  82.     &optional (message `make_simple_string("")`)
  83.     &key (block Ct) console debug dir input output username
  84.          list data (ioc Ct)
  85.          (prtype Kswappable))
  86.  
  87.     object s;
  88.     int ier, ac0, ac1, ac2, ac3;
  89.     int i, j, len;
  90.     char *c;
  91.     char prog[256];
  92.     char mess[512];
  93.     char dirname[256];
  94.     char consname[256];
  95.     char inputname[256];
  96.     char outputname[256];
  97.     char user[256];
  98.     char listname[256];
  99.     char dataname[256];
  100.     P_PROC pack;
  101.     P_ISEND pack1;
  102.  
  103. @
  104.     check_type_string(&progname);
  105.     check_type_string(&message);
  106.  
  107.     j = progname->st.st_fillp;
  108.     c = progname->st.st_self;
  109.  
  110.     if (j > 255)
  111.         FEerror("The program name ~A is too long.", 1, progname);
  112.  
  113.     for (i = 0; i < j; i++)        /* copy program name */
  114.         prog[i] = toupper(c[i]);
  115.     prog[i] = '\0';
  116.  
  117.     j = message->st.st_fillp;
  118.     c = message->st.st_self;
  119.  
  120.     if (j > 510)
  121.         FEerror("The ipc message ~A is too long.", 1, message);
  122.  
  123.     for (i = 0; i < j; i++)        /* copy ipc message */
  124.         mess[i] = c[i];
  125.     mess[i++] = '\0';
  126.     mess[i] = '\0';
  127.  
  128.     len = (i + 1) / 2;            /* ipc message length */
  129.  
  130.     /* build ?proc packet */
  131.  
  132.     pack.pflg = 0;
  133.     if (block != Cnil) pack.pflg |= $PFEX;
  134.     if (debug != Cnil) pack.pflg |= $PFDB;
  135.  
  136.     if (prtype == Kswappable)
  137.         ;
  138.     else if (prtype == Kpre_emptive)
  139.         pack.pflg |= $PFRP;
  140.     else if (prtype == Kresident)
  141.         pack.pflg |= $PFRS;
  142.     else
  143.         FEerror("~S is an illegal process type.", 1, prtype);
  144.  
  145.     pack.ppri = -1;
  146.     pack.psnm = prog;
  147.     pack.pipc = &pack1;
  148.     pack.pnm = -1;
  149.     pack.pmem = -1;
  150.  
  151.     pack.pdir = -1;
  152.     if (dir != Cnil) {
  153.         if (type_of(dir) != t_string)
  154.             FEwrong_type_argument(Sstring, dir);
  155.         string_copy(dir, dirname);
  156.         pack.pdir = dirname;
  157.     }
  158.  
  159.     if (ioc != Cnil) {
  160.         pack.pcon = -1;
  161.         pack.pifp = -1;
  162.         pack.pofp = -1;
  163.     } else {
  164.         pack.pcon = 0;
  165.         pack.pifp = 0;
  166.         pack.pofp = 0;
  167.     }
  168.  
  169.     if (console != Cnil) {
  170.         if (type_of(console) != t_string)
  171.             FEwrong_type_argument(Sstring, console);
  172.         string_copy(console, consname);
  173.         pack.pcon = consname;
  174.     }
  175.  
  176.     pack.pcal =  -1;
  177.     pack.pwss = -1;
  178.  
  179.     pack.punm = -1;
  180.     if (username != Cnil) {
  181.         if (type_of(username) != t_string)
  182.             FEwrong_type_argument(Sstring, username);
  183.         string_copy(username, user);
  184.         pack.punm = user;
  185.     }
  186.  
  187.     pack.pprv = -1;
  188.     pack.ppcr = -1;
  189.     pack.pwmi =  -1;
  190.     pack.proc_res = -1;
  191.  
  192.     if (input != Cnil) {
  193.         if (type_of(input) != t_string)
  194.             FEwrong_type_argument(Sstring, input);
  195.         string_copy(input, inputname);
  196.         pack.pifp = inputname;
  197.     }
  198.  
  199.     if (output != Cnil) {
  200.         if (type_of(output) != t_string)
  201.             FEwrong_type_argument(Sstring, output);
  202.         string_copy(output, outputname);
  203.         pack.pofp = outputname;
  204.     }
  205.  
  206.     pack.plfp= 0;
  207.     if (list != Cnil)
  208.         if (list = Ct)
  209.             pack.plfp = -1;
  210.         else {
  211.             if (type_of(list) != t_string)
  212.                 FEwrong_type_argument(Sstring, list);
  213.             string_copy(list, listname);
  214.             pack.plfp = listname;
  215.         }
  216.  
  217.     pack.pdfp= 0;
  218.     if (data != Cnil)
  219.         if (data = Ct)
  220.             pack.pdfp = -1;
  221.         else {
  222.             if (type_of(data) != t_string)
  223.                 FEwrong_type_argument(Sstring, data);
  224.             string_copy(data, dataname);
  225.             pack.pdfp = dataname;
  226.         }
  227.  
  228.     pack.smch=  -1;
  229.  
  230.     /* build ipc packet */
  231.  
  232.     pack1.isfl = 0;
  233.     pack1.iufl = $RFCF;        /* cli format */
  234.     pack1.idph = 0;
  235.     pack1.iopn = 0;
  236.     pack1.ilth = len;
  237.     pack1.iptr = (short *)mess;
  238.  
  239.     ac2 = &pack;
  240.     if (ier = sys($PROC,&ac0,&ac1,&ac2))
  241.         sys_emes(ier);
  242.  
  243.     @(return Ct)
  244. @)
  245.  
  246. check_termination(ms)
  247. char *ms;
  248. {
  249.     int ier, ac0, ac1, ac2, ac3, pc, carry, trap;
  250.     int i, j;
  251.     short fl;
  252.     char rmess[512];
  253.     P_ISEND pack;
  254.  
  255.     zero(rmess, 512);
  256.  
  257.     pack.isfl = $IFNBK;
  258.     pack.iufl = 0;
  259.     pack.idph = $SPTM;
  260.     pack.iopn = 0;
  261.     pack.iptr = (short *)rmess;
  262.     pack.ilth = 256;
  263.     ac2 = &pack;
  264.     ier = sys($IREC, &ac0, &ac1,&ac2);
  265.  
  266.     if (ier == ERNMS)
  267.         return(FALSE);
  268.     if (ier != 0) sys_emes(ier);
  269.  
  270.     fl = pack.iufl;
  271.  
  272.     switch(fl & 03400) {
  273.     case $TEXT:
  274.         if (*(short *)rmess == $TR32)  goto TRAP32;
  275.  
  276.         ms[0] = '\0';
  277.         if (fl & $RFEC) {
  278.             if (fl & $RFWA)
  279.                 strcpy(ms, "*WARNING*\n");
  280.             else if (fl & $RFER)
  281.                 strcpy(ms, "*ERROR*\n");
  282.             else
  283.                 strcpy(ms, "*ABORT*\n");
  284.         }
  285.         if (*((short *)rmess + 1) != 0) {
  286.             strcat(ms, rmess+8);
  287.             if (fl & $RFEC) strcat(ms, "\n");
  288.         }
  289.         if (fl & $RFEC) {
  290.             ier = *(int *)(rmess + 4);
  291.             getemes(ier, rmess);
  292.             strcat(ms, rmess);
  293.         }
  294.         return(TRUE);
  295.  
  296.     case $TSELF:
  297.         ms[0] = '\0';
  298.         if (fl & $RFEC) {
  299.             if (fl & $RFWA)
  300.                 strcpy(ms, "*WARNING*\n");
  301.             else if (fl & $RFER)
  302.                 strcpy(ms, "*ERROR*\n");
  303.             else
  304.                 strcpy(ms, "*ABORT*\n");
  305.         }
  306.         if (*(short *)rmess != 0) {
  307.             strcat(ms, rmess+4);
  308.             if (fl & $RFEC) strcat(ms, "\n");
  309.         }
  310.         if (fl & $RFEC) {
  311.             ier = *(short *)(rmess + 2);
  312.             getemes(ier, rmess);
  313.             strcat(ms, rmess);
  314.         }
  315.         return(TRUE);
  316.  
  317.     case $TRAP:
  318.         ac0 = *(short *)(rmess + 0);
  319.         ac1 = *(short *)(rmess + 2);
  320.         ac2 = *(short *)(rmess + 4);
  321.         ac3 = *(short *)(rmess + 6);
  322.         pc = *(short *)(rmess + 8);
  323.         carry = (pc & 0100000) ? 1 : 0;
  324.         pc &= 077777;
  325.         sprintf(ms,
  326.         "*TRAP*\nC: %o PC: %o AC0: %o AC1: %o AC2: %o AC3: %o",
  327.             carry, pc, ac0, ac1, ac2, ac3);
  328.         return(TRUE);
  329.  
  330.     case $TCIN:
  331.         strcpy(ms, "*ABORT*\nCONSOLE INTERRUPT");
  332.         return(TRUE);
  333.  
  334.     case $TSUP:
  335.         strcpy(ms,"*ABORT*\nTERMINATED BY A SUPERIOR PROCESS");
  336.         return(TRUE);
  337.  
  338.     case $TAOS:
  339.         ier = pack.iptr;
  340.         getemes(ier, rmess);
  341.         strcpy(ms, "TERMINATED BY AOS/VS\n");
  342.         strcat(ms, rmess);
  343.         return(TRUE);
  344.  
  345.     default:
  346.         ms[0] = '\0';
  347.         return(TRUE);
  348.  
  349.     }    /* end of switch */
  350.  
  351. TRAP32:
  352.     ac0 = *(int *)(rmess + 2);
  353.     ac1 = *(int *)(rmess + 6);
  354.     ac2 = *(int *)(rmess + 10);
  355.     ac3 = *(int *)(rmess + 14);
  356.     pc = *(int *)(rmess + 18);
  357.     carry = (pc & 020000000000) ? 1:0;
  358.     pc &= 017777777777;
  359.     sprintf(ms,
  360.     "*TRAP*\nC: %o PC: %o AC0: %o AC1: %o AC2: %o AC3: %o",
  361.         carry, pc, ac0, ac1, ac2, ac3);
  362.     return(TRUE);
  363. }
  364.  
  365. Ltermination_message()
  366. {
  367.     char    mess[512];
  368.  
  369.     check_arg(0);
  370.  
  371.     zero(mess, 512);
  372.     if (check_termination(mess) == TRUE)
  373.         vs_push(make_simple_string(mess));
  374.     else
  375.         vs_push(Cnil);
  376. }
  377.  
  378. Llast_termination_message()
  379. {
  380.     char mess[512], mess1[512];
  381.     int i;
  382.  
  383.     check_arg(0);
  384.  
  385.     i = 0;
  386.     zero(mess, 512);
  387.     while (check_termination(mess) == TRUE) {
  388.         i++;
  389.         blockmove(mess1, mess, 512);
  390.         zero(mess);
  391.     }
  392.     if (i > 0)
  393.         vs_push(make_simple_string(mess1));
  394.     else
  395.         vs_push(Cnil);
  396. }
  397.  
  398.  
  399. /*
  400.     IPC routines
  401.  
  402.         SI:ILKUP
  403.         SI:IREC
  404.         SI:ISEND
  405.         SI:CREATE-IPC-FILE
  406. */
  407.  
  408. /*
  409.     (SI:ILKUP pathname)
  410.  
  411.         returns the global port number of the IPC file `pathname'.
  412. */
  413. siLilkup()
  414. {
  415.     int ac0, ac1, ac2;
  416.     char buffer[2048];
  417.     int i, ier;
  418.  
  419.     check_arg(1);
  420.     check_type_or_pathname_string_symbol_stream(&vs_base[0]);
  421.     vs_base[0] = coerce_to_pathname(vs_base[0]);
  422.     vs_base[0] = coerce_to_namestring(vs_base[0]);
  423.     if (vs_base[0]->st.st_fillp > 2047)
  424.         FEerror("The namestring ~A is too long.", 1, vs_base[0]);
  425.     for (i = 0;  i < vs_base[0]->st.st_fillp;  i++)
  426.         buffer[i] = vs_base[0]->st.st_self[i];
  427.     buffer[i] = '\0';
  428.     ac0 = (int)buffer;
  429.     ac1 = 0;
  430.     ac2 = 0;
  431.     ier = sys($ILKUP, &ac0, &ac1, &ac2);
  432.     if (ier != 0)
  433.         sys_emes(ier);
  434.     vs_base[0] = make_fixnum(ac1);
  435. }
  436.  
  437. /*
  438.     (SI:IREC global-port-number local-port-number string)
  439.  
  440.         receives a message from the specified port into `string'.
  441.         `string' must have a fill-pointer.
  442.         The port numbers should be fixnums.
  443. */        
  444. siLirec()
  445. {
  446.     int ac0, ac1, ac2;
  447.     struct p_irec p;
  448.     char buffer[2048];
  449.     char *s;
  450.     int f, d;
  451.     int i, ier;
  452.  
  453.     check_arg(3);
  454.     if (type_of(vs_base[0]) != t_fixnum)
  455.         FEerror("~S is an illegal global port number.",1,vs_base[0]);
  456.     if (type_of(vs_base[1]) != t_fixnum)
  457.         FEerror("~S is an illegal local port number.", 1, vs_base[1]);
  458.      check_type_string(&vs_base[2]);
  459.     if (!vs_base[2]->st.st_hasfillp)
  460.         FEerror("~S does not have a fill-pointer.", 1, vs_base[2]);
  461.     p.isfl = 0;
  462.     p.iufl = 0;
  463.     p.ioph = fix(vs_base[0]);
  464.     p.idpn = fix(vs_base[1]);
  465.     f = vs_base[2]->st.st_fillp;
  466.     d = vs_base[2]->st.st_dim - f;
  467.     s = vs_base[2]->st.st_self + f;
  468.     if ((int)s & 1) {
  469.         p.ilth = d/2 < 2048 ? d/2 : 2048;
  470.         p.iptr = buffer;
  471.         ac0 = 0;
  472.         ac1 = 0;
  473.         ac2 = (int)(&p);
  474.         if (ier = sys($IREC, &ac0, &ac1, &ac2))
  475.             sys_emes(ier);
  476.         for (i = 0;  i < p.ilth*2;  i++)
  477.             s[i] = buffer[i];
  478.         vs_base[2]->st.st_fillp += p.ilth*2;
  479.     } else {
  480.         p.ilth = d/2;
  481.         p.iptr = s;
  482.         ac0 = 0;
  483.         ac1 = 0;
  484.         ac2 = (int)(&p);
  485.         if (ier = sys($IREC, &ac0, &ac1, &ac2))
  486.             sys_emes(ier);
  487.         vs_base[2]->st.st_fillp += p.ilth*2;
  488.     }
  489.     vs_pop;
  490.     vs_pop;
  491.     vs_base[0] = Cnil;
  492. }
  493.  
  494. /*
  495.     (SI:ISEND global-port-number local-port-number string)
  496.  
  497.         sends a message in `string' to the specified port.
  498.         The length of `string' must be even.
  499.         The port numbers should be fixnums.
  500. */        
  501. siLisend()
  502. {
  503.     int ac0, ac1, ac2;
  504.     struct p_isend p;
  505.     char buffer[2048];
  506.     char *s;
  507.     int f;
  508.     int i, ier;
  509.  
  510.     check_arg(3);
  511.     if (type_of(vs_base[0]) != t_fixnum)
  512.         FEerror("~S is an illegal global port number.",1,vs_base[0]);
  513.     if (type_of(vs_base[1]) != t_fixnum)
  514.         FEerror("~S is an illegal local port number", 1, vs_base[1]);
  515.      check_type_string(&vs_base[2]);
  516.     if (vs_base[2]->st.st_fillp%2 != 0)
  517.         FEerror("The length of the message ~A is odd.",1,vs_base[2]);
  518.     p.isfl = 0;
  519.     p.iufl = 0;
  520.     p.idph = fix(vs_base[0]);
  521.     p.iopn = fix(vs_base[1]);
  522.     f = vs_base[2]->st.st_fillp;
  523.     s = vs_base[2]->st.st_self;
  524.     p.ilth = f/2;
  525.     if ((int)s & 1) {
  526.         if (f > 2048)
  527.             FEerror("The message ~S is too long.", 1, vs_base[2]);
  528.         for (i = 0;  i < f;  i++)
  529.             buffer[i] = s[i];
  530.         p.iptr = buffer;
  531.     } else
  532.         p.iptr = s;
  533.     ac0 = 0;
  534.     ac1 = 0;
  535.     ac2 = (int)(&p);
  536.     ier = sys($ISEND, &ac0, &ac1, &ac2);
  537.     if (ier != 0)
  538.         sys_emes(ier);
  539.     vs_pop;
  540.     vs_pop;
  541.     vs_base[0] = Cnil;
  542. }
  543.  
  544. /*
  545.     (SI:CREATE-IPC-FILE pathname local-port-number)
  546.  
  547.         creates an IPC file named `pathname'.
  548.         `local-port-number' is given to the IPC file.
  549.         It should be a fixnum.
  550. */
  551. siLcreate_ipc_file()
  552. {
  553.     int ac0, ac1, ac2;
  554.     struct p_create_ipc p;
  555.     char buffer[2048];
  556.     int i, ier;
  557.     
  558.     check_arg(2);
  559.     check_type_or_pathname_string_symbol_stream(&vs_base[0]);
  560.     vs_base[0] = coerce_to_pathname(vs_base[0]);
  561.     vs_base[0] = coerce_to_namestring(vs_base[0]);
  562.     if (vs_base[0]->st.st_fillp > 2047)
  563.         FEerror("The namestring ~A is too long.", 1, vs_base[0]);
  564.     for (i = 0;  i < vs_base[0]->st.st_fillp;  i++)
  565.         buffer[i] = vs_base[0]->st.st_self[i];
  566.     buffer[i] = '\0';
  567.     if (type_of(vs_base[1]) != t_fixnum)
  568.         FEerror("~S is an illegal local port number.", 1, vs_base[1]);
  569.     p.cftyp_entry = $FIPC;
  570.     p.cpor = fix(vs_base[1]);
  571.     p.ctim = -1;
  572.     p.cacp = -1;
  573.     ac0 = (int)buffer;
  574.     ac1 = 0;
  575.     ac2 = (int)(&p);
  576.     if (ier = sys($CREATE, &ac0, &ac1, &ac2))
  577.         sys_emes(ier);
  578.     vs_pop;
  579.     vs_base[0] = Cnil;
  580. }
  581.  
  582.  
  583. init_process(start, size, data)
  584. char *start;
  585. int size;
  586. object data;
  587. {
  588.     Kblock = make_keyword("BLOCK");
  589.     Kconsole = make_keyword("CONSOLE");
  590.     Kdebug = make_keyword("DEBUG");
  591.     Kdir = make_keyword("DIR");
  592.     Kusername = make_keyword("USERNAME");
  593.     Klist = make_keyword("LIST");
  594.     Kdata = make_keyword("DATA");
  595.     Kioc = make_keyword("IOC");
  596.  
  597.     Kprtype = make_keyword("PRTYPE");
  598.     Kswappable = make_keyword("SWAPPABLE");
  599.     Kpre_emptive = make_keyword("PRE-EMPTIVE");
  600.     Kresident = make_keyword("RESIDENT");
  601.  
  602.     make_function("PROCESS", Lprocess);
  603.     make_function("TERMINATION-MESSAGE", Ltermination_message);
  604.     make_function("LAST-TERMINATION-MESSAGE",
  605.               Llast_termination_message);
  606.  
  607.  
  608.     make_si_function("ILKUP", siLilkup);
  609.     make_si_function("IREC", siLirec);
  610.     make_si_function("ISEND", siLisend);
  611.     make_si_function("CREATE-IPC-FILE", siLcreate_ipc_file);
  612. }
  613.